unit arithmetic;

interface

uses classes,sysutils,vm,io,math

;

procedure arithmeticwords(vm:TKsanaForthVM);
implementation

procedure forth_zero(vm:TKsanaForthVM);
begin vm.push(0); end;

procedure forth_one(vm:TKsanaForthVM);
begin vm.push(1); end;

procedure forth_two(vm:TKsanaForthVM);
begin vm.push(2); end;

procedure forth_three(vm:TKsanaForthVM);
begin vm.push(3); end;

procedure forth_four(vm:TKsanaForthVM);
begin vm.push(4); end;

procedure forth_cell(vm:TKsanaForthVM);
begin vm.push(CELLSIZE); end;

procedure forth_f(vm:TKsanaForthVM);
begin vm.push($f); end;

procedure forth_ff(vm:TKsanaForthVM);
begin vm.push($ff); end;

procedure forth_minus1(vm:TKsanaForthVM);
begin vm.push(-1); end;

procedure forth_and(vm:TKsanaForthVM);
begin vm.tos:=vm.pop and vm.tos;
end;

procedure forth_or(vm:TKsanaForthVM);
begin vm.tos:=vm.pop or vm.tos;
end;

procedure forth_xor(vm:TKsanaForthVM);
begin vm.tos:=vm.pop xor vm.tos;
end;

procedure forth_not(vm:TKsanaForthVM);
begin vm.tos:=not vm.tos;
end;

procedure forth_negate(vm:TKsanaForthVM);
begin vm.tos:=-vm.tos;
end;

procedure forth_dnegate(vm:TKsanaForthVM);
begin vm.dpush(-vm.dpop);
end;

procedure forth_plus(vm:TKsanaForthVM);
begin vm.tos:=vm.pop+vm.tos;
end;

procedure forth_dplus(vm:TKsanaForthVM);
begin vm.dpush(vm.dpop+vm.dpop);
end;

procedure forth_star(vm:TKsanaForthVM);
begin vm.tos:=vm.pop*vm.tos;
end;

procedure forth_dstar(vm:TKsanaForthVM);
begin vm.dpush(vm.dpop*vm.dpop);
end;

procedure forth_minus(vm:TKsanaForthVM);
var n:integer;
begin n:=vm.pop; vm.tos:=vm.tos-n;
end;

procedure forth_dminus(vm:TKsanaForthVM);
var d:int64;
begin d:=vm.dpop; vm.dpush(vm.dpop-d);
end;

procedure forth_slash(vm:TKsanaForthVM);
var n:integer;
begin n:=vm.pop; vm.tos:=vm.tos div n;
end;

procedure forth_dslash(vm:TKsanaForthVM);
var d:int64;
begin d:=vm.dpop; vm.dpush(trunc(vm.dpop/d));
end;

procedure forth_stod(vm:TKsanaForthVM);
begin vm.dpush(vm.pop);
end;

procedure forth_mod(vm:TKsanaForthVM);
var n:integer;
begin n:=vm.pop; vm.tos:=vm.tos mod n;
end;
procedure forth_slashmod(vm:TKsanaForthVM);
var a,b:integer;
begin a:=vm.sec; b:=vm.tos; vm.tos:=a div b; vm.sec:=a mod b;
end;
procedure forth_oneplus(vm:TKsanaForthVM);
begin vm.tos:=vm.tos+1;
end;

procedure forth_cellminus(vm:TKsanaForthVM);
begin vm.tos:=vm.tos-CELLSIZE;
end;

procedure forth_twoplus(vm:TKsanaForthVM);
begin vm.tos:=vm.tos+2;
end;

procedure forth_twominus(vm:TKsanaForthVM);
begin vm.tos:=vm.tos-2;
end;

procedure forth_cellplus(vm:TKsanaForthVM);
begin vm.tos:=vm.tos+CELLSIZE;
end;

procedure forth_oneminus(vm:TKsanaForthVM);
begin vm.tos:=vm.tos-1;
end;

procedure forth_NE(vm:TKsanaForthVM);
begin vm.tos:=integer(vm.pop<>vm.tos);
end;

procedure forth_LE(vm:TKsanaForthVM);
begin vm.tos:=integer(vm.pop>=vm.tos);
end;

procedure forth_GE(vm:TKsanaForthVM);
begin vm.tos:=integer(vm.pop<=vm.tos);
end;

procedure forth_EQ(vm:TKsanaForthVM);
begin vm.tos:=integer(vm.pop=vm.tos);
end;

procedure forth_GT(vm:TKsanaForthVM);
begin vm.tos:=integer(vm.pop<vm.tos);
end;

procedure forth_LT(vm:TKsanaForthVM);
begin vm.tos:=integer(vm.pop>vm.tos);
end;

procedure forth_0LT(vm:TKsanaForthVM);
begin vm.tos:=integer(vm.tos<0);
end;

procedure forth_0GT(vm:TKsanaForthVM);
begin vm.tos:=integer(vm.tos>0);
end;

procedure forth_0EQ(vm:TKsanaForthVM);
begin vm.tos:=integer(vm.tos=0);
end;

procedure forth_0LE(vm:TKsanaForthVM);
begin vm.tos:=integer(vm.tos<=0);
end;

procedure forth_0GE(vm:TKsanaForthVM);
begin vm.tos:=integer(vm.tos>=0);
end;

procedure forth_0NE(vm:TKsanaForthVM);
begin vm.tos:=integer(vm.tos<>0);
end;

procedure forth_cells(vm:TKsanaForthVM);
begin vm.tos:=integer(vm.tos*sizeof(integer));
end;

procedure forth_sqrt(vm:TKsanaForthVM); /// 100. sqrt f. ==> 10
var n:single; i:integer;
begin
  i:=vm.tos; n:=sqrt(psingle(@i)^); vm.tos:=pinteger(@n)^;
end;

procedure forth_pi(vm:TKsanaForthVM); /// pi f. ==> 3.14159274101257
var n:single;
begin
  n:=pi;
  vm.push(pinteger(@n)^);
end;

procedure forth_toradius(vm:TKsanaForthVM);
var n:single;
begin
  n:=pi/180*vm.tos;
  vm.tos:=pinteger(@n)^;
end;

procedure forth_todegree(vm:TKsanaForthVM);
var n:single; i:integer;
begin
  i:=vm.tos;
  n:=psingle(@i)^*180/pi;
  vm.tos:=round(n);
end;

procedure forth_trunc(vm:TKsanaForthVM);
var i:integer; s:single;
begin
  i:=vm.tos;
  s:=single((@i)^);
  i:=trunc(s);  //// 20100726 sam
  vm.tos:=i;
end;

procedure forth_tofloat(vm:TKsanaForthVM);
var n:single;
begin
  n:=vm.tos;
  vm.tos:=pinteger(@n)^;
end;

procedure forth_fplus(vm:TKsanaForthVM);
var i:integer; n:single;
begin i:=vm.pop; n:=psingle(@i)^; i:=vm.tos;
  n:=psingle(@i)^+n; vm.tos:=pinteger(@n)^;
end;

procedure forth_fminus(vm:TKsanaForthVM);
var i:integer; n:single;
begin i:=vm.pop; n:=psingle(@i)^; i:=vm.tos;
  n:=psingle(@i)^-n; vm.tos:=pinteger(@n)^;
end;

procedure forth_fstar(vm:TKsanaForthVM);
var i:integer; n:single;
begin i:=vm.pop; n:=psingle(@i)^; i:=vm.tos;
  n:=psingle(@i)^*n; vm.tos:=pinteger(@n)^;
end;

procedure forth_fslash(vm:TKsanaForthVM);
var i:integer; n:single;
begin i:=vm.pop; n:=psingle(@i)^; i:=vm.tos;
  n:=psingle(@i)^/n; vm.tos:=pinteger(@n)^;
end;

procedure forth_fdotr(vm:TKsanaForthVM); //// pi 9.6 f.r ==> " 3.141593"
var i,L,F:integer; s:string;             //// pi 5 f.r ==> " 3.14"
begin i:=vm.pop; L:=floor(psingle(@i)^);
  if L=0 then begin
      s:='%'+format('%df',[i]);
  end else begin
      F:=floor((psingle(@i)^-L)*10);
      if L<F then L:=F;
      s:='%'+format('%d.%df',[L,F]);
  end;
  i:=vm.tos;
  s:=format(s,[psingle(@i)^]);
  vm.tos:=integer(pchar(s));
  forth_ztype(vm);
end;

procedure forth_fdot(vm:TKsanaForthVM); /// pi f. ==> "3.14"
begin
  forth_zero(vm); forth_fdotr(vm);
end;

procedure forth_floor(vm:TKsanaForthVM);
var i:integer; f:single;
begin i:=vm.tos; f:=floor(psingle(@i)^);
      vm.tos:=integer((@f)^);
end;

procedure forth_round(vm:TKsanaForthVM);
var i:integer; f:single;
begin i:=vm.tos; f:=round(psingle(@i)^);
 vm.tos:=integer((@f)^);
end;

procedure forth_sin(vm:TKsanaForthVM);
var i:integer; f:single;
begin i:=vm.tos; f:=sin(psingle(@i)^); vm.tos:=pinteger(@f)^;
end;

procedure forth_cos(vm:TKsanaForthVM);
var i:integer; f:single;
begin i:=vm.tos;

f:=cos(psingle(@i)^);

 vm.tos:=pinteger(@f)^;
end;


procedure forth_tan(vm:TKsanaForthVM);
var i:integer; f:single;
begin i:=vm.tos; f:=tan(psingle(@i)^); vm.tos:=pinteger(@f)^;
end;

procedure forth_cot(vm:TKsanaForthVM);
var i:integer; f:single;
begin i:=vm.tos; f:=cotan(psingle(@i)^); vm.tos:=pinteger(@f)^;
end;

procedure forth_arcsin(vm:TKsanaForthVM);
var i:integer; f:single;
begin i:=vm.tos; f:=arcsin(psingle(@i)^); vm.tos:=pinteger(@f)^;
end;

procedure forth_arccos(vm:TKsanaForthVM);
var i:integer; f:single;
begin i:=vm.tos; f:=arccos(psingle(@i)^); vm.tos:=pinteger(@f)^;
end;

procedure forth_arctan(vm:TKsanaForthVM);
var i:integer; f:single;
begin i:=vm.tos; f:=arctan(psingle(@i)^); vm.tos:=pinteger(@f)^;
end;
{$IFDEF DELPHI}
procedure forth_arccot(vm:TKsanaForthVM);
var i:integer; f:single;
begin i:=vm.tos; f:=arccot(psingle(@i)^); vm.tos:=pinteger(@f)^;
end;
{$ENDIF}

procedure forth_exp(vm:TKsanaForthVM);
var i:integer; f:single;
begin i:=vm.tos; f:=exp(psingle(@i)^); vm.tos:=pinteger(@f)^;
end;

procedure forth_ln(vm:TKsanaForthVM);
var i:integer; f:single;
begin i:=vm.tos; f:=ln(psingle(@i)^); vm.tos:=pinteger(@f)^;
end;

procedure arithmeticwords(vm:TKsanaForthVM);
begin
  vm.addcodeword('0=',integer(@forth_0EQ));  //// ( i -- f )
  vm.addcodeword('0>',integer(@forth_0GT));  //// ( i -- f )
  vm.addcodeword('0<',integer(@forth_0LT));  //// ( i -- f )
  vm.addcodeword('0<>',integer(@forth_0NE)); //// ( i -- f )
  vm.addcodeword('0>=',integer(@forth_0GE)); //// ( i -- f )
  vm.addcodeword('0<=',integer(@forth_0LE)); //// ( i -- f )

  vm.addcodeword('>',integer(@forth_GT));    //// ( i j -- f )
  vm.addcodeword('<',integer(@forth_LT));    //// ( i j -- f )
  vm.addcodeword('=',integer(@forth_EQ));    //// ( i j -- f )
  vm.addcodeword('>=',integer(@forth_GE));   //// ( i j -- f )
  vm.addcodeword('<=',integer(@forth_LE));   //// ( i j -- f )
  vm.addcodeword('<>',integer(@forth_NE));   //// ( i j -- f )

  vm.addcodeword('0',integer(@forth_zero));  //// ( -- 0 )
  vm.addcodeword('1',integer(@forth_one));   //// ( -- 1 )
  vm.addcodeword('2',integer(@forth_two));   //// ( -- 2 )
  vm.addcodeword('3',integer(@forth_three)); //// ( -- 3 )
  vm.addcodeword('4',integer(@forth_four));  //// ( -- 4 )
  vm.addcodeword('$F',integer(@forth_f));    //// ( -- $F )
  vm.addcodeword('$FF',integer(@forth_ff));  //// ( -- $FF )
  vm.addcodeword('-1',integer(@forth_minus1)); //// ( -- -1 )

  vm.addcodeword('and',integer(@forth_and)); /// and ( i j -- k ) bitwise and
  vm.addcodeword('or',integer(@forth_or));  //// or ( i j -- k ) bitwise or
  vm.addcodeword('xor',integer(@forth_xor)); //// xor ( i j -- k ) bitwise xor
  vm.addcodeword('not',integer(@forth_not)); //// not ( i -- j ) bitwise not

  vm.addcodeword('negate',integer(@forth_negate)); //// negate ( i -- -i )
  vm.addcodeword('+',integer(@forth_plus)); //// + ( i j -- i+j )
  vm.addcodeword('*',integer(@forth_star)); //// * ( i j -- i*j )
  vm.addcodeword('-',integer(@forth_minus)); //// - ( i j -- i-j )
  vm.addcodeword('/',integer(@forth_slash)); //// / ( i j -- i/j )
  vm.addcodeword('s>d',integer(@forth_stod)); //// / ( i -- ilow ihigh )
  vm.addcodeword('dnegate',integer(@forth_dnegate)); //// negate ( d -- -d )
  vm.addcodeword('d+',integer(@forth_dplus)); //// + ( d1 d2 -- d1+d2 )
  vm.addcodeword('d*',integer(@forth_dstar)); //// * ( d1 d2 -- d1*d2 )
  vm.addcodeword('d-',integer(@forth_dminus)); //// - ( d1 d2 -- d1-d2 )
  vm.addcodeword('d/',integer(@forth_dslash)); //// / ( d1 d2 -- d1/d2 )
  vm.addcodeword('mod',integer(@forth_mod)); //// mod ( i j -- m )
  vm.addcodeword('/mod',integer(@forth_slashmod)); //// /mod ( i j k -- i/j m )
  vm.addcodeword('cells',integer(@forth_cells)); //// ( i -- i*4 )

  vm.addcodeword('1+',integer(@forth_oneplus)); //// ( i -- i+1 )
  vm.addcodeword('1-',integer(@forth_oneminus)); //// ( i -- i-1 )
  vm.addcodeword('2+',integer(@forth_twoplus)); //// ( i -- i+2 )
  vm.addcodeword('2-',integer(@forth_twominus)); //// ( i -- i-2 )
  vm.addcodeword('cell+',integer(@forth_cellplus)); //// ( i -- i+4 )
  vm.addcodeword('cell-',integer(@forth_cellminus)); //// ( i -- i-4 )

  vm.addcodeword('round',integer(@forth_round)); //// ( a -- round(a) ) float
  vm.addcodeword('floor',integer(@forth_floor)); //// ( a -- floor(a) ) float
  vm.addcodeword('pi',integer(@forth_pi)); //// ( -- pi ) float
  vm.addcodeword('>radius',integer(@forth_toradius)); //// ( deg -- rad ) float
  vm.addcodeword('>degree',integer(@forth_todegree)); //// ( rad -- deg ) float
  vm.addcodeword('trunc',integer(@forth_trunc)); //// ( a -- i )
  vm.addcodeword('>float',integer(@forth_tofloat)); //// ( i -- a )
  vm.addcodeword('f.',integer(@forth_fdot)); //// ( a -- )
  vm.addcodeword('f.r',integer(@forth_fdotr)); //// ( a n.m -- ) pi 9.6 f.r ==> " 3.141593"
  vm.addcodeword('f+',integer(@forth_fplus)); //// ( a b -- a+b )
  vm.addcodeword('f*',integer(@forth_fstar)); //// ( a b -- a*b )
  vm.addcodeword('f-',integer(@forth_fminus)); //// ( a b -- a-b )
  vm.addcodeword('f/',integer(@forth_fslash)); //// ( a b -- a/b )
  vm.addcodeword('exp',integer(@forth_exp)); //// ( a -- exp(a) )
  vm.addcodeword('ln',integer(@forth_ln)); //// ( a -- ln(a) )
  vm.addcodeword('sqrt',integer(@forth_sqrt)); //// ( a -- sqrt(a) )
  vm.addcodeword('sin',integer(@forth_sin)); //// ( a -- sin(a) )
  vm.addcodeword('cos',integer(@forth_cos)); //// ( a -- cos(a) )
  vm.addcodeword('tan',integer(@forth_tan)); //// ( a -- tan(a) )
  vm.addcodeword('cot',integer(@forth_cot)); //// ( a -- cot(a) )
  vm.addcodeword('arcsin',integer(@forth_arcsin)); //// ( a -- arcsin(a) )
  vm.addcodeword('arccos',integer(@forth_arccos)); //// ( a -- arccos(a) )
  vm.addcodeword('arctan',integer(@forth_arctan)); //// ( a -- arctan(a) )
  vm.addcodeword('arccot',integer(@forth_arccot)); //// ( a -- arccot(a) )
{$IFDEF DELPHI}
{$ENDIF}

end;

end.
